home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / highlight.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  9.8 KB  |  324 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # procedures to manage highlighting.  Highlighting comes in two flavors
  8. # (which are sufficiently unrelated as to belong in different files).
  9. # The window highlights are red borders around the active widget.  The
  10. # border is a rectagular "frame" managed (with the placer) by the widget, 
  11. # but stacked below it.
  12.  
  13. # The resize handles are little squares at the corners and sides of the active
  14. # widget that are used for interactive resizing.  The "handles" are managed
  15. # by the widgets outline(see outline.tk), so they stick to the edges of
  16. # the widgets cavity.
  17.  
  18. # draw a highlight frame around a window
  19. # arguments
  20. #  win: the window to highlight
  21. #  border: the size of the border around the window
  22. #  name: - don't change.  Used to name highlight windows
  23. #  conf: - don't change.  Used internally for managing recursion
  24. # return value
  25. #  The name of the highlight window
  26. # side affects
  27. #  add a binding tag to the window to pick up configure events
  28. # notes
  29. #  This version uses the new placer stuff
  30.  
  31. proc window_highlight {win {border 2} {name highlight} {conf 0}} {
  32.     set new ${win}_$name
  33.     catch {frame $new -bg red -relief raised -bd 1}
  34.     place $new -in $win -bordermode outside -relx 0 -rely 0 \
  35.             -relwidth 1 -relheight 1 \
  36.             -x -$border  -y  -$border \
  37.             -width [expr 2 * $border] \
  38.             -height [expr 2 * $border]
  39.     lower $new $win
  40.     return $new
  41. }
  42.  
  43. # unhighlight a window (or all windows)
  44. # arguments
  45. #  win: window to "un-highlight" (or all highlighted object)
  46. #  name: - don't change (must match highlight_window name)
  47. # returns
  48. #  window that was un-highlighted
  49.  
  50. proc window_unhighlight {{win ""} {name highlight}} {
  51.     if {$win == ""} {    
  52.         set result ""
  53.         foreach i [info commands *.*_$name] {
  54.             regsub "(.+)_$name" $i {\1} win
  55.             lappend result [window_unhighlight $win $name]
  56.         }
  57.         return $result
  58.     }
  59.     if {![winfo exists [set del ${win}_$name]]} {
  60.         # puts " no $del to unhighlight"
  61.         return ""
  62.     }
  63.     destroy $del
  64.     return $win
  65. }
  66.  
  67.  
  68. # Add resize handles to a widget.  The resize handles consist of 8 (or 9)
  69. # squares placed around the edges and sides of a widget's cavity.
  70.  
  71. # arguments
  72. #  master:    The window to add resize handles around (usually the outline)
  73. #             <masterframe>.<widget name>_outline
  74. #  size:    the size of the highlight frame border (see highlight_window)
  75. #  extra:    the amount the resize handles protrude into the window
  76. #  color:    the color of the resize handles
  77. # return value
  78. #  the name of the resize frame
  79.  
  80. set Handle_Cursors { \
  81.     top_left_corner    top_side    top_right_corner \
  82.     left_side          cross       right_side \
  83.     bottom_left_corner bottom_side bottom_right_corner
  84. }
  85.  
  86. proc add_resize_handles {master {size 5} {extra 3} {color gray35}} {
  87.     global Handle_Cursors
  88.     set z [expr $size + $extra]
  89.  
  90.     foreach i {0 1 2 3 4 5 6 7 8 } {
  91.         set x [expr ($i%3)]
  92.         set y [expr ($i/3)]
  93.         set anchor [lindex {"n" "" "s"} $y][lindex {"w" "" "e"} $x]
  94.         # If a "center" handle is desired, swap comment the following 2 lines
  95.         # if {$i == 4} {set anchor c}
  96.         if {$i == 4} {continue}
  97.         # resize handles should be siblings of their widgets, so they
  98.         # are always visible floating "above" the widget.
  99.         # pick a name that can be parsed to retrieve the outline, widget,
  100.         #   anchor, and widget master, that is a sibling of the widget
  101.         set name .can.f.[winfo name $master]:$anchor
  102.         catch {frame $name -relief raised -bd 1}
  103.         $name configure -width $z -height $z \
  104.             -bg $color -cursor [lindex $Handle_Cursors $i]
  105.         place $name -in $master -relx [expr $x/2.0] -rely [expr $y/2.0] \
  106.                 -anchor $anchor -bordermode outside
  107.         bindtags $name "resize [winfo toplevel $name] all"
  108.     }
  109. }
  110.  
  111. # destroy all resize handles managed in master. (if any)
  112. # Resize handles should be the only slaves of the outline, so destroying
  113. # all of its slaves should be adaquate
  114.  
  115. proc del_resize_handles {master} {
  116.     eval "destroy [info commands .*_outline:*]" 
  117.     
  118. }
  119.  
  120. # parameters for moving resize handles.  For each resize handle, we only
  121. # change either x or y of the managing frame, which we keep track of here.
  122. # The coordinate names (-x, -y) are chosen to match the "place" option names
  123. # The coords +x and +y are easier to use than -width and -height
  124.  
  125. # map from  a resize handle name to the coordinate that needs to be adjusted
  126. array set Adjust {
  127.     n.y  -y        s.y  +y        w.x  -x        e.x  +x
  128.     nw.x -x     nw.y -y        ne.x +x     ne.y -y
  129.     sw.x -x     sw.y +y        se.x +x     se.y +y
  130. }
  131.  
  132. # adjust the resize frame, called from bind with %W %X %Y
  133. # %W is the resize handle, named: .can.f.<name of outline's widget>:<anchor code>
  134. # The outline is named: <frame managing widget>.<widget name>_outline
  135.  
  136. proc resize_sweep {win x y} {
  137.     global Adjust Current _Message
  138.     upvar #0 geom:$Current(frame) data
  139.  
  140.     # make coords relative to parent
  141.  
  142.     incr x -[winfo rootx $Adjust(parent)]
  143.     incr y -[winfo rooty $Adjust(parent)]
  144.  
  145.     # make modulo row/col (is this better?)
  146.  
  147.     set row [expr [blt_table row $Current(frame) location $y] & ~1]
  148.     set col [expr [blt_table column $Current(frame) location $x] & ~1]
  149.     if {$row < 2 || $col < 2} return
  150.     if {($row == $Adjust(row)) && ($col == $Adjust(column))} return
  151.     set Adjust(row) $row; set Adjust(column) $col
  152.     if {![get_position r1 c1 r2 c2]} return
  153.      if {![position_ok $Adjust(owner) $r1 $c1 $r2 $c2]} return
  154.      foreach i {r1 c1 r2 c2} {set Adjust($i) [set $i]}    ;# last good position
  155.     if {$row > $Adjust(start_row)} { incr row -1}
  156.     if {$col > $Adjust(start_column)} { incr col -1}
  157.     set y $data(row_$row)
  158.     set x $data(column_$col)
  159.  
  160.     # do the replacement
  161.  
  162.     foreach coord {x y} {
  163.         set index $Adjust(how).$coord
  164.         if {[info exists Adjust($index)]} {
  165.             set Adjust([set Adjust($index)]) [set $coord]
  166.         }
  167.     }
  168.  
  169.     # move the "box" by extracting the proper array elements
  170.  
  171.     set Adjust(-width) [expr $Adjust(+x) - $Adjust(-x)]
  172.     set Adjust(-height) [expr $Adjust(+y) - $Adjust(-y)]
  173.     eval "place $Adjust(master) [array get Adjust -*]"
  174. }
  175.  
  176. # temporary binding stuff
  177. #    <prefix>_down:  The button went down
  178. #    <prefix>_start_sweep    We started a sweep
  179. #    <prefix>_sweep            We are sweeping
  180. #     <prefix>_end_sweep        We ended the sweep (button up)
  181. #     <prefix>_up            button up - no sweep
  182.  
  183. proc resize_down {win x y} {
  184.     global _Message Cancel
  185.     after cancel $Cancel
  186.     set _Message "Drag past grid-line to change span"
  187. }
  188.  
  189. # We started a sweep.  Compute relevent information
  190.  
  191. proc resize_start_sweep {win x y} {
  192.     global Adjust
  193.  
  194.     set Adjust(win) $win                    ;# The name of the resize handle
  195.     regexp {.can.f.(.*)_outline:(.*)$} $win dummy owner Adjust(how)
  196.     set Adjust(owner) .can.f.$owner                ;# The widget owning the outline
  197.     set Adjust(parent)    .can.f[find_master .can.f.$owner]        ;# The parent frame
  198.     array set temp [place info $win]
  199.     set Adjust(master) $temp(-in)
  200.     array set Adjust [place info $Adjust(master)]
  201.     set Adjust(+x) [expr $Adjust(-x) + $Adjust(-width)] 
  202.     set Adjust(+y) [expr $Adjust(-y) + $Adjust(-height)]
  203.     set Adjust(row) ""
  204.     set Adjust(column) ""
  205.  
  206.     blt_get .can.f.$owner info
  207.     set Adjust(start_row) $info(-row)
  208.     set Adjust(start_column) $info(-column)
  209.     set Adjust(end_row) [expr $info(-row) + $info(-rowspan) - 1]
  210.     set Adjust(end_column) [expr $info(-column) + $info(-columnspan) - 1]
  211.     set Adjust(revert) [place info $Adjust(master)]
  212.     set Adjust(r1) $Adjust(start_row)
  213.     set Adjust(c1) $Adjust(start_column)
  214.     set Adjust(r2) $Adjust(end_row)
  215.     set Adjust(c2) $Adjust(end_column)
  216.  
  217.     # kludge to get around serious implicit-grab bug in TK
  218.     # That causes an implicit grab to be released when "%W" is moved
  219.     grab $win
  220. }
  221.  
  222. # change the widget position by adjusting the span and/or row/col
  223.  
  224. proc resize_end_sweep {win x y} {
  225.  
  226.     # undo grab kludge
  227.     grab release $win
  228.  
  229.     global Adjust
  230.  
  231.     set column $Adjust(c1); set row $Adjust(r1)
  232.     set rowspan [expr $Adjust(r2) - $row + 1]
  233.     set columnspan [expr $Adjust(c2) - $column + 1]
  234.     set widget $Adjust(owner)
  235.     blt_table .can.f[find_master $widget] $widget $row,$column \
  236.         -rowspan $rowspan -columnspan $columnspan
  237.     foreach i {row column columnspan rowspan} {
  238.         sync_form $i [set $i]
  239.     }
  240.  
  241.  
  242.     return 1
  243. }
  244.  
  245. # We could use this as a short cut for setting the edge stickyness
  246.  
  247. proc resize_up {win x y} {
  248. }
  249.  
  250. # check to make sure widget can occupy slot(s)
  251. # This is brute force for now, it should be made faster,
  252. # Since it needs to be run at mouse-motion time
  253. # All of the info needed for this is already packaged in the Adjust
  254. # array, so don't bother passing in all of the parameters
  255.  
  256. # convert Adjustment position into starting and ending rows and columns
  257.  
  258. proc get_position {R1 C1 R2 C2} {
  259.     global Adjust
  260.     upvar $R1 r1  $C1 c1  $R2 r2  $C2 c2
  261.  
  262.     foreach element {
  263.             row column owner how start_row start_column end_row end_column} {
  264.         set $element $Adjust($element)
  265.     }
  266.  
  267.     switch -glob $how {
  268.         n*  {
  269.             if {$row > $end_row} {return 0}
  270.             set r1 $row; set r2 $end_row
  271.         }
  272.         s* {
  273.             if {$row <= $start_row} {return 0}
  274.             set r1 $start_row; set r2 $row; incr r2 -2
  275.         }
  276.         * {
  277.             set r1 $start_row; set r2 $end_row
  278.         }
  279.     }
  280.  
  281.     switch -glob $how {
  282.         *w  {
  283.             if {$column > $end_column} {return 0}
  284.             set c1 $column; set c2 $end_column
  285.         }
  286.         *e {
  287.             if {$column <= $start_column} {return 0}
  288.             set c1 $start_column; set c2 $column; incr c2 -2
  289.         }
  290.         * {
  291.             set c1 $start_column; set c2 $end_column
  292.         }
  293.     }
  294.     return 1
  295. }
  296.  
  297. # See if rows and column range is empty
  298.  
  299. proc position_ok {widget r1 c1 r2 c2 {result _Message}} {
  300.     global Current Adjust
  301.     upvar #0 geom:$Current(frame) data
  302.     upvar $result _Message
  303.  
  304.     dputs "OK? $widget (in $Current(frame)) $r1,$c1 $r2,$c2"
  305.     if {$r1 <2 || $c1 < 2 || $r2 >= $data(rows) || $c2 >= $data(columns)} {
  306.         set _Message "Location is past the edge of the table"
  307.         dputs " PAST EDGE"
  308.         return 0
  309.     }
  310.     for {} {$r1 <= $r2} {incr r1 2} {
  311.         for {set c $c1} {$c <= $c2} {incr c 2} {
  312.             set win [blt_table slaves $Current(frame) -row $r1 -column $c]
  313.             if {$win == ""} continue
  314.             if {$widget != $win} {
  315.                 set _Message "Location is occupied (by [winfo name $win])"
  316.                 return 0
  317.             }
  318.         }
  319.     }
  320.     set _Message ""
  321.     # puts "  OK"
  322.     return 1
  323. }
  324.